home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_pcdp / adas / expr.pas < prev    next >
Pascal/Delphi Source File  |  1996-01-30  |  8KB  |  273 lines
  1. unit expr;
  2.  
  3.   { Compile expressions including
  4.       assignment statements and procedure calls }
  5.  
  6. interface
  7. uses global, util;
  8. procedure selector(level: integer; var v: item);
  9. procedure expression(level: integer; var x: item);
  10. procedure call(level: integer; i: integer);
  11. procedure assignment(level,i: integer; lv, ad:integer);
  12.  
  13. implementation
  14.  
  15.   procedure selector(level: integer; var v: item);
  16.   var x: item;
  17.       a,j: integer;
  18.   begin
  19.     if sy <> lparent then error(ertyp);
  20.     insymbol;
  21.     expression(level, x);
  22.     if v.typ <> arrays then error(ertyp);
  23.     a := v.ref;
  24.     if atab[a].inxtyp <> x.typ then error(ertyp);
  25.     emit1(21,a);
  26.     v.typ := atab[a].eltyp;
  27.     v.ref := 0;
  28.     if sy = rparent then insymbol else error(erpun)
  29.   end;
  30.  
  31.   procedure call(level: integer; i: integer);
  32.   var x: item;
  33.       lastp, cp: integer;
  34.  
  35.     procedure valueparameter;
  36.     begin
  37.       expression(level, x);
  38.       if x.typ <> tab[cp].typ then error(ertyp);
  39.       if x.typ = arrays then error(ertyp);      { arrays not allowed }
  40.       if x.ref <> tab[cp].ref then error(ertyp);
  41.     end;
  42.  
  43.     procedure variableparameter;
  44.     var k: integer;
  45.     begin
  46.       if sy <> ident then error(erid);
  47.       k := loc(level, id);
  48.       insymbol;
  49.       if k = 0 then error(ernf);
  50.       with tab[k] do
  51.         begin
  52.         if obj <> variable then error(erpar);
  53.         x.typ := typ;
  54.         x.ref := ref;
  55.         if normal then emit2(0, lev, adr) else
  56.           emit2(1, lev, adr);
  57.         if sy = lparent then
  58.           selector(level, x);
  59.         if (x.typ <> tab[cp].typ) or (x.ref <> tab[cp].ref) then
  60.             error(ertyp)
  61.         end
  62.     end;
  63.  
  64.   begin (* call *)
  65.     emit1(18,i);  (* markstack *)
  66.     lastp := btab[tab[i].ref].lastpar;
  67.     cp := i;
  68.     if sy = lparent then
  69.       begin
  70.       repeat
  71.         insymbol;
  72.         if cp >= lastp then error(erpar);
  73.         cp := cp + 1;
  74.         if tab[cp].normal then valueparameter else variableparameter
  75.       until sy <> comma;
  76.       if sy = rparent then insymbol else error(erpun)
  77.       end;
  78.     if cp < lastp then error(erpar); (* too few actual parms *)
  79.     emit1(19, btab[tab[i].ref].psize-1);
  80.     if tab[i].lev < level then emit2(3, tab[i].lev, level)
  81.   end;
  82.  
  83.   function resulttype(a,b: types): types;
  84.   begin
  85.     if (a>ints) or (b>ints) then error(ertyp);
  86.     if (a=notyp) or (b=notyp) then resulttype := notyp
  87.       else resulttype := ints
  88.   end;
  89.  
  90.   procedure expression(level: integer; var x: item);
  91.   var y: item;
  92.       op: symbol;
  93.  
  94.     procedure simpleexpression(var x: item);
  95.     var y: item;
  96.         op: symbol;
  97.  
  98.       procedure term(var x: item);
  99.       var y: item;
  100.           op: symbol;
  101.           ts: typset;
  102.  
  103.         procedure factor(var x: item);
  104.         var i,f: integer;
  105.         begin
  106.           x.typ := notyp;
  107.           x.ref := 0;
  108.           while sy in facbegsys do
  109.             begin
  110.             if sy = ident then
  111.               begin
  112.               i := loc(level, id);
  113.               if i = 0 then error(ernf);
  114.               insymbol;
  115.               with tab[i] do
  116.               case obj of
  117.                 konstant:
  118.                   begin
  119.                   x.typ := typ;
  120.                   x.ref := 0;
  121.                   emit1(24, adr)
  122.                   end;
  123.                 variable:
  124.                   begin
  125.                   x.typ := typ;
  126.                   x.ref := ref;
  127.                   if sy = lparent then
  128.                     begin
  129.                     if normal then f := 0 else f := 1;
  130.                     emit2(f, lev, adr);
  131.                     selector(level, x);
  132.                     if x.typ in stantyps then emit(34) else error(ertyp)
  133.                     end
  134.                   else begin
  135.                     if not(x.typ in stantyps) then error(ertyp);
  136.                     if normal then f := 1 else f := 2;
  137.                     emit2(f, lev, adr)
  138.                     end
  139.                   end;
  140.                 type1, prozedure, task: error(ertyp);
  141.               end (* case *)
  142.               end
  143.             else if sy in [charcon, intcon] then
  144.               begin
  145.               if sy = charcon then x.typ := chars else x.typ := ints;
  146.               emit1(24, inum);
  147.               x.ref := 0;
  148.               insymbol
  149.               end
  150.             else if sy = lparent then
  151.               begin
  152.               insymbol;
  153.               expression(level, x);
  154.               if sy = rparent then insymbol else error(erpun)
  155.               end
  156.             else if sy = notsy then
  157.               begin
  158.               insymbol;
  159.               factor(x);
  160.               if x.typ = bools then emit(35)
  161.               else if x.typ <> notyp then error(ertyp)
  162.               end;
  163.             end (* while *)
  164.         end;
  165.  
  166.       begin(* term *)
  167.         factor(x);
  168.         while sy in [times, idiv, imod, andsy] do
  169.           begin
  170.           op := sy;
  171.           insymbol;
  172.           factor(y);
  173.           if op = times then
  174.             begin
  175.             x.typ := resulttype(x.typ, y.typ);
  176.             if x.typ = ints then emit(57)
  177.             end
  178.           else if op = andsy then
  179.             begin
  180.             if (x.typ = bools) and (y.typ = bools) then emit(56)
  181.             else begin
  182.               if (x.typ <> notyp) and (y.typ <> notyp) then error(ertyp);
  183.               x.typ := notyp
  184.               end
  185.             end
  186.           else begin (* op in [idiv, imod *)
  187.             if (x.typ = ints) and (y.typ = ints) then
  188.               if op = idiv then emit(58) else emit(59)
  189.             else begin
  190.               if (x.typ <> notyp) and (y.typ <> notyp) then error(ertyp);
  191.               x.typ := notyp
  192.               end
  193.             end
  194.           end
  195.       end;
  196.  
  197.     begin (* simpleexpression *)
  198.       if sy in [plus, minus] then
  199.         begin
  200.         op := sy;
  201.         insymbol;
  202.         term(x);
  203.         if x.typ > ints then error(ertyp)
  204.         else if op = minus then emit(36)
  205.         end
  206.       else term(x);
  207.       while sy in [plus, minus, orsy] do
  208.         begin
  209.         op := sy;
  210.         insymbol;
  211.         term(y);
  212.         if op = orsy then
  213.           begin
  214.           if (x.typ = bools) and (y.typ = bools) then emit(51)
  215.           else begin
  216.             if (x.typ <> notyp) and (y.typ <> notyp) then error(ertyp);
  217.             x.typ := notyp
  218.             end
  219.           end
  220.         else begin
  221.           x.typ := resulttype(x.typ, y.typ);
  222.           if x.typ = ints then
  223.             if op = plus then emit(52) else emit(53)
  224.           end
  225.         end
  226.     end;
  227.  
  228.   begin (* expression *)
  229.     simpleexpression(x);
  230.     if sy in [eql, neq, gtr, lss, leq, geq] then
  231.       begin
  232.       op := sy;
  233.       insymbol;
  234.       simpleexpression(y);
  235.       if (x.typ in [notyp, ints, bools, chars]) and (x.typ = y.typ) then
  236.         case op of
  237.           eql: emit(45);
  238.           neq: emit(46);
  239.           lss: emit(47);
  240.           leq: emit(48);
  241.           gtr: emit(49);
  242.           geq: emit(50)
  243.         end
  244.       else error(ertyp);
  245.       x.typ := bools
  246.     end
  247.   end;
  248.  
  249.   procedure assignment(level, i: integer; lv, ad: integer);
  250.   var x, y: item;
  251.       f: integer;
  252.       watch: boolean;
  253.       { Standard variables (integer, character, boolean)
  254.           will be "watched": store will print value }
  255.   begin
  256.     watch := true;
  257.     x.typ := tab[i].typ;
  258.     x.ref := tab[i].ref;
  259.     if tab[i].normal then f := 0
  260.       else begin watch := false; f := 1 end;
  261.     emit2(f, lv, ad);
  262.     if sy = lparent then
  263.       begin
  264.       watch := false; selector(level, x) end;
  265.     if sy = becomes then insymbol else error(erpun);
  266.     expression(level, y);
  267.     if (x.typ = y.typ) and (x.typ in stantyps)
  268.       then if watch then emit1(38, i) { save tab index for watch }
  269.                     else emit1(38, 0) { 0 = no watch }
  270.       else error(ertyp)
  271.   end;
  272.  
  273. end.